Attribute VB_Name = "modFreight"
'---------------------------------------------------------------------------------------
'Module : modFreight
'Date   : 20070601-01
'Author : Chris Elwell
'Purpose: Contains the routines required for rating FedEx Freight
'         Public Function BuildFreightRate() As String - builds the request URL
'
'         Private Function ConvertClass(ByVal str6105 As String) As String - converts the
'                           FXRS format NMFC to API format.
'         Public Function SendXMLData(ByVal strXML As String) As String - sends the XML request
'         Public Function ParseXMLReply(ByVal strXMLReply As String) As String - parses the XML reply
'
'---------------------------------------------------------------------------------------
'
Public Function BuildFreightRate() As String

    On Error GoTo EH
    
    Dim strTrans As String              'URL string
    Dim rsLTL As New ADODB.Recordset    'recordset of line items from LTLMulti table
    Dim strQuery As String              'SELECT query
    Dim i As Integer                    'counter
    
    strQuery = "SELECT * FROM LTLMulti WHERE f1 = '" & g_str1 & "'"
    rsLTL.Open strQuery, g_connFSMSClient, adOpenStatic, adLockOptimistic
    
    strTrans = ""
    
    strTrans = "http://www.fedexfreight.fedex.com/XMLRating.jsp?"
    strTrans = strTrans + "as_shipterms=" & IIf(g_str6107 = "1", "prepaid", "collect")    'Ship terms - prepaid or collect
    strTrans = strTrans + "&as_shzip=" & g_str9                                         'Shipper ZIP
    strTrans = strTrans + "&as_shcntry=" & g_str117                                     'Shipper Country
    strTrans = strTrans + "&as_cnzip=" & g_str17                                        'Consignee ZIP
    strTrans = strTrans + "&as_cncntry=" & g_str50                                      'Consignee Country
    strTrans = strTrans + "&as_decvalue=" & g_str26                                     'Declared value
    strTrans = strTrans + "&as_iamthe=" & "shipper"                                     'Role of requestor
    strTrans = strTrans + "&as_acctnbr=" & frmSetup.txtLTLAcctNum                       'Acct #
        
    If Not rsLTL.EOF Then
        'Multi-occurrence fields from LTLMulti table
        For i = 1 To rsLTL.RecordCount
            strTrans = strTrans + "&as_class" & Trim(Str(i)) & "=" & ConvertClass(rsLTL!f6105)    'NMFC Class
            strTrans = strTrans + "&as_weight" & Trim(Str(i)) & "=" & rsLTL!f1670                 'Weight
            strTrans = strTrans + "&as_pcs" & Trim(Str(i)) & "=" & rsLTL!f2931                    '# of pieces
            strTrans = strTrans + "&as_nmfc" & Trim(Str(i)) & "=" & rsLTL!f6106                   'NMCF Item #
            strTrans = strTrans + "&as_haz" & Trim(Str(i)) & "=" & rsLTL!f1331                    'Haz flag
            
            rsLTL.MoveNext
        Next
        
    End If
    'Add COD Fields
    If g_str27 = "Y" Then
        strTrans = strTrans + "&as_codamount=" & g_str53                                'COD Amount
        strTrans = strTrans + "&as_codfee=" & IIf(g_str6107 = "1", "CFP", "CFC")          'Prepaid or collect
    End If
    
    'Special Svcs
    strTrans = strTrans + "&as_insidepickup=" & IIf(g_str1120 = "Y", "Y", "N")          'Inside P/U
    strTrans = strTrans + "&as_insidedelivery=" & IIf(g_str1121 = "Y", "Y", "N")        'Inside Del
    strTrans = strTrans + "&as_residentialdelivery=" & IIf(g_str440 = "Y", "Y", "N")    'Res Del
    
    'Add Special svcs from field 6110
    strTrans = strTrans + "&as_residentialpickup=" & IIf(Mid(g_str6110, 7, 1) = "Y", "Y", "N")      'Res P/U
    strTrans = strTrans + "&as_freezable=" & IIf(Mid(g_str6110, 2, 1) = "Y", "Y", "N")              'Freezable protection
    strTrans = strTrans + "&as_callbefore=" & IIf(Mid(g_str6110, 1, 1) = "Y", "Y", "N")             'Call Before Del
    strTrans = strTrans + "&as_liftgate=" & IIf(Mid(g_str6110, 11, 1) = "Y", "Y", "N")              'Lift Gate Required
    strTrans = strTrans + "&as_singleshipment=" & IIf(Mid(g_str6110, 9, 1) = "Y", "Y", "N")         'Single Shipment
    strTrans = strTrans + "&as_limitedaccesspickup=" & IIf(Mid(g_str6110, 3, 1) = "Y", "Y", "N")    'Limited Access P/U
    strTrans = strTrans + "&as_limitedaccessdelivery=" & IIf(Mid(g_str6110, 4, 1) = "Y", "Y", "N")  'Limited Access Del

    BuildFreightRate = strTrans

Release:
    If rsLTL.State = adStateOpen Then rsLTL.Close
    Set rsLTL = Nothing
    
    Exit Function

EH:
    MsgBox Err.Description, vbCritical, "modFreight:BuildFreightRate"
    Resume Release

End Function
Private Function ConvertClass(ByVal str6105 As String) As String

    On Error GoTo EH
    
    If Len(str6105) > 1 Then
        str6105 = Left(str6105, Len(str6105) - 2)
        If Len(str6105) = 2 Then str6105 = "0" & str6105
        
        ConvertClass = str6105
    Else
        
        ConvertClass = ""
        
    End If
    
    Exit Function

EH:
    MsgBox Err.Description, vbCritical, "modFreight:BuildFreightRate"

End Function

Public Function SendXMLData(ByVal strXML As String) As String

    On Error GoTo EH
    
    Dim FSO As New FileSystemObject
    Dim TSO As TextStream
    Dim strXMLFileSpec As String
    Dim strXMLReply As String
    
    strXMLFileSpec = App.Path & "\" & Format(Now, "YYYYMMDD_HHMMSS") & ".XML"
    
    If strXML <> "" Then strXMLReply = frmClose.Inet1.OpenURL(strXML)

    If strXMLReply <> "" Then
        Set TSO = FSO.OpenTextFile(strXMLFileSpec, ForWriting, True)
        'MsgBox strXMLReply
        TSO.Write strXMLReply
        TSO.Close
    
        SendXMLData = strXMLFileSpec
    Else
        SendXMLData = ""
    End If

Release:
    Set TSO = Nothing
    Set FSO = Nothing
    
    Exit Function

EH:
    MsgBox Err.Description, vbCritical, "modFreight:SendXMLData"
    Resume Release
    
End Function
Public Function ParseXMLReply(ByVal strXMLFileSpec As String) As String

    On Error GoTo EH
    
    '20070926-01 Changed to MSXML3 from MSXML6
    Dim oXMLDoc As New MSXML2.DOMDocument30
    Dim oRootElement As MSXML2.IXMLDOMElement
    Dim oNode As MSXML2.IXMLDOMNode
    Dim FSO As New Scripting.FileSystemObject
    Dim strNodeValues() As String
    
    If Not FSO.FileExists(strXMLFileSpec) Then
    
        g_str3 = "LTL Rating Error"
        Exit Function
    
    End If
    
    ' Load DOM
    oXMLDoc.async = False
    oXMLDoc.Load strXMLFileSpec
    
    Set oRootElement = oXMLDoc.documentElement
    
    'Check for rating error
    If oRootElement.nodeName = "RatingError" Then
        
        g_str3 = oRootElement.Text
        g_str29 = ""
        g_str37 = ""
        g_str3058 = ""
    
    Else
        g_str3 = ""
        
        'Get ProNumber, NetFreightCharges, TransitDays
        For Each oNode In oRootElement.childNodes
            If oNode.nodeName = "ProNumber" Then
                g_str29 = oNode.Text
            ElseIf oNode.nodeName = "NetFreightCharges" Then
                g_str37 = oNode.Text
            ElseIf oNode.nodeName = "TransitDays" Then
                g_str3058 = oNode.Text
            End If
        Next
    
    End If

    FSO.DeleteFile strXMLFileSpec, True
    
Release:
    Set FSO = Nothing
    
    Exit Function

EH:
    MsgBox Err.Description, vbCritical, "modFreight:ParseXMLReply"
    Resume Release
    
End Function
